; ORIGINAL: 3dt2.1/examples/smartpos.scm
; $Id: smartpos.scm,v 1.4 1997/04/30 20:24:19 jread Exp $
;----------------------------------------------------------------------
; purpose---
;    Rubberbanding with smart positions
;----------------------------------------------------------------------
;;
(require 'cmd "cmd.scm")
(require 'acis "acis.scm")
(require 'old-rb "old-rb.scm")

(define highlight-position '())
(let ((Last-Position #f)
      (Last-Point-Style '())
      (Last-View #f)
      )
  (set! highlight-position
        (lambda ( pt style view)
          (if (and Last-Position Last-View)
              (begin
                (view:set-point-style Last-Point-Style Last-View)
                (view:set-rb-mode #t Last-View)
                (view:draw-point Last-Position Last-View)
                (view:set-rb-mode #f Last-View)
                (set! Last-Position #f)
                ))
          (if pt
              (begin
                (set! Last-Position pt)
                (set! Last-Point-Style style)
                (set! Last-View view)
                (view:set-point-style Last-Point-Style Last-View)
                (view:set-rb-mode #t Last-View)
                (view:draw-point Last-Position Last-View)
                (view:set-rb-mode #f Last-View)
                ))
          )))

(define Point-Select-Dist 5)

(define smart-pos '())

(let ((last-entity #f)
      (start-pos (position 0 0 0))
      (end-pos (position 0 0 0))
      (mid-pos (position 0 0 0))
      )
  (set! smart-pos
        (lambda (pe)
          (let* ((eray (pick:entity-with-ray pe 4))
                 (ent (entray:entity eray))
                 (pray (entray:ray eray))
                 (pt (ray:position pray))
                 )
            (if (edge? ent)
                (begin
                  (if (not (eq? ent last-entity))
                      (begin
                        (set! last-entity ent)
                        (set! start-pos (curve:start-pos ent))
                        (set! end-pos (curve:end-pos ent))
                        (set! mid-pos (curve:eval-pos ent .5))
                        ))

                  (cond
                    ((< (position:distance start-pos pray) Point-Select-Dist)
                     (set! pt start-pos)
                     (highlight-position pt "o" (event:view pe))
                     )
                    ((< (position:distance end-pos pray) Point-Select-Dist)
                     (set! pt end-pos)
                     (highlight-position pt "o" (event:view pe))
                     )
                    ((< (position:distance mid-pos pray) Point-Select-Dist)
                     (set! pt mid-pos)
                     (highlight-position pt "+" (event:view pe))
                     )
                    (else
                      (set! pt (car (curve:ray-pos eray)))
                      (highlight-position pt "x" (event:view pe))
                      )
                    ))

                ; no entity picked, just return screen position
                (highlight-position #f #f #f)
                (set! pt (pick:position pe))
                )
            pt
            ))))

;;======================================================================

(define (smart-rb-pos)
  (set! rb-start-hook (lambda (p) (smart-pos p)))
  (set! rb-update-hook (lambda (p) (smart-pos p)))
  (set! rb-stop-hook (highlight-position #f #f #f))
  (rb:scheme #t)
  )

(define (smart-line)
  (cmd:set
    `(edge:linear
       ,(arg:desc smart-pos
                  '(smart-rb-pos)
                  (lambda (p) (rb:line #t p))
                  )
       ,(arg:desc smart-pos
                  #f
                  '(begin
                     (rb:line #f)
                     (rb:scheme #f)
                     )
                  ))))
